home *** CD-ROM | disk | FTP | other *** search
/ FishMarket 1.0 / FishMarket v1.0.iso / fishies / 376-400 / disk_386 / xlispstat / src1.lzh / XLisp / xlbfun.c < prev    next >
C/C++ Source or Header  |  1990-10-03  |  13KB  |  682 lines
  1. /* xlbfun.c - xlisp basic built-in functions */
  2. /* Copyright (c) 1989, by David Michael Betz.                            */
  3. /* You may give out copies of this software; for conditions see the file */
  4. /* COPYING included with this distribution.                              */
  5.  
  6. #include <string.h>
  7. #include "xlisp.h"
  8. #include "osdef.h"
  9. #ifdef ANSI
  10. #include "xlproto.h"
  11. #else
  12. #include "xlfun.h"
  13. #endif ANSI
  14. #include "xlvar.h"
  15.  
  16. /* forward declarations */
  17. #ifdef ANSI
  18. LVAL makesymbol(int);
  19. #else
  20. LVAL makesymbol();
  21. #endif ANSI
  22.  
  23. /* xeval - the built-in function 'eval' */
  24. LVAL xeval()
  25. {
  26.     LVAL expr;
  27.  
  28.     /* get the expression to evaluate */
  29.     expr = xlgetarg();
  30.     xllastarg();
  31.  
  32.     /* evaluate the expression */
  33.     return (xleval(expr));
  34. }
  35.  
  36. /* xapply - the built-in function 'apply' */
  37. LVAL xapply()
  38. {
  39.     LVAL fun,arglist;
  40.  
  41.     /* get the function and argument list */
  42.     fun = xlgetarg();
  43.     arglist = xlgalist();
  44.     xllastarg();
  45.  
  46.     /* apply the function to the arguments */
  47.     return (xlapply(pushargs(fun,arglist)));
  48. }
  49.  
  50. /* xfuncall - the built-in function 'funcall' */
  51. LVAL xfuncall()
  52. {
  53.     LVAL *newfp;
  54.     int argc;
  55.     
  56.     /* build a new argument stack frame */
  57.     newfp = xlsp;
  58.     pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
  59.     pusharg(xlgetarg());
  60.     pusharg(NIL); /* will be argc */
  61.  
  62.     /* push each argument */
  63.     for (argc = 0; moreargs(); ++argc)
  64.     pusharg(nextarg());
  65.  
  66.     /* establish the new stack frame */
  67.     newfp[2] = cvfixnum((FIXTYPE)argc);
  68.     xlfp = newfp;
  69.  
  70.     /* apply the function to the arguments */
  71.     return (xlapply(argc));
  72. }
  73.  
  74. /* xmacroexpand - expand a macro call repeatedly */
  75. LVAL xmacroexpand()
  76. {
  77.     LVAL form;
  78.     form = xlgetarg();
  79.     xllastarg();
  80.     return (xlexpandmacros(form));
  81. }
  82.  
  83. /* x1macroexpand - expand a macro call */
  84. LVAL x1macroexpand()
  85. {
  86.     LVAL form,fun,args;
  87.  
  88.     /* protect some pointers */
  89.     xlstkcheck(2);
  90.     xlsave(fun);
  91.     xlsave(args);
  92.  
  93.     /* get the form */
  94.     form = xlgetarg();
  95.     xllastarg();
  96.  
  97.     /* expand until the form isn't a macro call */
  98.     if (consp(form)) {
  99.     fun = car(form);        /* get the macro name */
  100.     args = cdr(form);        /* get the arguments */
  101.     if (symbolp(fun) && fboundp(fun)) {
  102.         fun = xlgetfunction(fun);    /* get the expansion function */
  103.         macroexpand(fun,args,&form);
  104.     }
  105.     }
  106.  
  107.     /* restore the stack and return the expansion */
  108.     xlpopn(2);
  109.     return (form);
  110. }
  111.  
  112. /* xatom - is this an atom? */
  113. LVAL xatom()
  114. {
  115.     LVAL arg;
  116.     arg = xlgetarg();
  117.     xllastarg();
  118.     return (atom(arg) ? true : NIL);
  119. }
  120.  
  121. /* xsymbolp - is this an symbol? */
  122. LVAL xsymbolp()
  123. {
  124.     LVAL arg;
  125.     arg = xlgetarg();
  126.     xllastarg();
  127.     return (arg == NIL || symbolp(arg) ? true : NIL);
  128. }
  129.  
  130. /* xnumberp - is this a number? */
  131. LVAL xnumberp()
  132. {
  133.     LVAL arg;
  134.     arg = xlgetarg();
  135.     xllastarg();
  136.     return ((fixp(arg) || floatp(arg) || complexp(arg)) ? true : NIL); /* L. Tierney */
  137. }
  138.  
  139. /* xintegerp - is this an integer? */
  140. LVAL xintegerp()
  141. {
  142.     LVAL arg;
  143.     arg = xlgetarg();
  144.     xllastarg();
  145.     return (fixp(arg) ? true : NIL);
  146. }
  147.  
  148. /* xfloatp - is this a float? */
  149. LVAL xfloatp()
  150. {
  151.     LVAL arg;
  152.     arg = xlgetarg();
  153.     xllastarg();
  154.     return (floatp(arg) ? true : NIL);
  155. }
  156.  
  157. /* xcharp - is this a character? */
  158. LVAL xcharp()
  159. {
  160.     LVAL arg;
  161.     arg = xlgetarg();
  162.     xllastarg();
  163.     return (charp(arg) ? true : NIL);
  164. }
  165.  
  166. /* xstringp - is this a string? */
  167. LVAL xstringp()
  168. {
  169.     LVAL arg;
  170.     arg = xlgetarg();
  171.     xllastarg();
  172.     return (stringp(arg) ? true : NIL);
  173. }
  174.  
  175. /* xarrayp - is this an array? */
  176. LVAL xarrayp()
  177. {
  178.     LVAL arg;
  179.     arg = xlgetarg();
  180.     xllastarg();
  181.     return (vectorp(arg) ? true : NIL);
  182. }
  183.  
  184. /* xstreamp - is this a stream? */
  185. LVAL xstreamp()
  186. {
  187.     LVAL arg;
  188.     arg = xlgetarg();
  189.     xllastarg();
  190.     return (streamp(arg) || ustreamp(arg) ? true : NIL);
  191. }
  192.  
  193. /* xobjectp - is this an object? */
  194. LVAL xobjectp()
  195. {
  196.     LVAL arg;
  197.     arg = xlgetarg();
  198.     xllastarg();
  199.     return (objectp(arg) ? true : NIL);
  200. }
  201.  
  202. /* xboundp - is this a value bound to this symbol? */
  203. LVAL xboundp()
  204. {
  205.     LVAL sym;
  206.     sym = xlgasymbol();
  207.     xllastarg();
  208.     return (boundp(sym) ? true : NIL);
  209. }
  210.  
  211. /* xfboundp - is this a functional value bound to this symbol? */
  212. LVAL xfboundp()
  213. {
  214.     LVAL sym;
  215.     sym = xlgasymbol();
  216.     xllastarg();
  217.     return (fboundp(sym) ? true : NIL);
  218. }
  219.  
  220. /* xnull - is this null? */
  221. LVAL xnull()
  222. {
  223.     LVAL arg;
  224.     arg = xlgetarg();
  225.     xllastarg();
  226.     return (null(arg) ? true : NIL);
  227. }
  228.  
  229. /* xlistp - is this a list? */
  230. LVAL xlistp()
  231. {
  232.     LVAL arg;
  233.     arg = xlgetarg();
  234.     xllastarg();
  235.     return (listp(arg) ? true : NIL);
  236. }
  237.  
  238. /* xendp - is this the end of a list? */
  239. LVAL xendp()
  240. {
  241.     LVAL arg;
  242.     arg = xlgalist();
  243.     xllastarg();
  244.     return (null(arg) ? true : NIL);
  245. }
  246.  
  247. /* xconsp - is this a cons? */
  248. LVAL xconsp()
  249. {
  250.     LVAL arg;
  251.     arg = xlgetarg();
  252.     xllastarg();
  253.     return (consp(arg) ? true : NIL);
  254. }
  255.  
  256. /* xeq - are these equal? */
  257. LVAL xeq()
  258. {
  259.     LVAL arg1,arg2;
  260.  
  261.     /* get the two arguments */
  262.     arg1 = xlgetarg();
  263.     arg2 = xlgetarg();
  264.     xllastarg();
  265.  
  266.     /* compare the arguments */
  267.     return (arg1 == arg2 ? true : NIL);
  268. }
  269.  
  270. /* xeql - are these equal? */
  271. LVAL xeql()
  272. {
  273.     LVAL arg1,arg2;
  274.  
  275.     /* get the two arguments */
  276.     arg1 = xlgetarg();
  277.     arg2 = xlgetarg();
  278.     xllastarg();
  279.  
  280.     /* compare the arguments */
  281.     return (eql(arg1,arg2) ? true : NIL);
  282. }
  283.  
  284. /* xequal - are these equal? (recursive) */
  285. LVAL xequal()
  286. {
  287.     LVAL arg1,arg2;
  288.  
  289.     /* get the two arguments */
  290.     arg1 = xlgetarg();
  291.     arg2 = xlgetarg();
  292.     xllastarg();
  293.  
  294.     /* compare the arguments */
  295.     return (equal(arg1,arg2) ? true : NIL);
  296. }
  297.  
  298. /* xset - built-in function set */
  299. LVAL xset()
  300. {
  301.     LVAL sym,val;
  302.  
  303.     /* get the symbol and new value */
  304.     sym = xlgasymbol();
  305.     val = xlgetarg();
  306.     xllastarg();
  307.  
  308.     /* check for a constant - L. Tierney */
  309.     if (isconstant(sym)) xlfail("can't assign to a constant");
  310.     
  311.     /* assign the symbol the value of argument 2 and the return value */
  312.     setvalue(sym,val);
  313.  
  314.     /* return the result value */
  315.     return (val);
  316. }
  317.  
  318. /* xgensym - generate a symbol */
  319. LVAL xgensym()
  320. {
  321.     char sym[STRMAX+11]; /* enough space for prefix and number */
  322.     LVAL x;
  323.  
  324.     /* get the prefix or number */
  325.     if (moreargs()) {
  326.     x = xlgetarg();
  327.     switch (ntype(x)) {
  328.     case SYMBOL:
  329.         x = getpname(x);
  330.     case STRING:
  331.         strncpy(gsprefix,getstring(x),STRMAX);
  332.         gsprefix[STRMAX] = '\0';
  333.         break;
  334.     case FIXNUM:
  335.         gsnumber = getfixnum(x);
  336.         break;
  337.     default:
  338.         xlbadtype(x);
  339.     }
  340.     }
  341.     xllastarg();
  342.  
  343.     /* create the pname of the new symbol */
  344.     sprintf(sym,"%s%d",gsprefix,gsnumber++);
  345.  
  346.     /* make a symbol with this print name */
  347.     return (xlmakesym(sym));
  348. }
  349.  
  350. /* xmakesymbol - make a new uninterned symbol */
  351. LVAL xmakesymbol()
  352. {
  353.     return (makesymbol(FALSE));
  354. }
  355.  
  356. /* xintern - make a new interned symbol */
  357. LVAL xintern()
  358. {
  359.     return (makesymbol(TRUE));
  360. }
  361.  
  362. /* makesymbol - make a new symbol */
  363. LOCAL LVAL makesymbol(iflag)
  364.   int iflag;
  365. {
  366.     LVAL pname;
  367.  
  368.     /* get the print name of the symbol to intern */
  369.     pname = xlgastring();
  370.     xllastarg();
  371.  
  372.     /* make the symbol */
  373.     return (iflag ? xlenter(getstring(pname))
  374.               : xlmakesym(getstring(pname)));
  375. }
  376.  
  377. /* xsymname - get the print name of a symbol */
  378. LVAL xsymname()
  379. {
  380.     LVAL sym;
  381.  
  382.     /* get the symbol */
  383.     sym = xlgasymbol();
  384.     xllastarg();
  385.  
  386.     /* return the print name */
  387.     return (getpname(sym));
  388. }
  389.  
  390. /* xsymvalue - get the value of a symbol */
  391. LVAL xsymvalue()
  392. {
  393.     LVAL sym,val;
  394.  
  395.     /* get the symbol */
  396.     sym = xlgasymbol();
  397.     xllastarg();
  398.  
  399.     /* get the global value */
  400.     while ((val = getvalue(sym)) == s_unbound)
  401.     xlunbound(sym);
  402.  
  403.     /* return its value */
  404.     return (val);
  405. }
  406.  
  407. /* xsymfunction - get the functional value of a symbol */
  408. LVAL xsymfunction()
  409. {
  410.     LVAL sym,val;
  411.  
  412.     /* get the symbol */
  413.     sym = xlgasymbol();
  414.     xllastarg();
  415.  
  416.     /* get the global value */
  417.     while ((val = getfunction(sym)) == s_unbound)
  418.     xlfunbound(sym);
  419.  
  420.     /* return its value */
  421.     return (val);
  422. }
  423.  
  424. /* xsymplist - get the property list of a symbol */
  425. LVAL xsymplist()
  426. {
  427.     LVAL sym;
  428.  
  429.     /* get the symbol */
  430.     sym = xlgasymbol();
  431.     xllastarg();
  432.  
  433.     /* return the property list */
  434.     return (getplist(sym));
  435. }
  436.  
  437. /* xget - get the value of a property */
  438. LVAL xget()
  439. {
  440.     LVAL sym,prp;
  441.  
  442.     /* get the symbol and property */
  443.     sym = xlgasymbol();
  444.     prp = xlgasymbol();
  445.     xllastarg();
  446.  
  447.     /* retrieve the property value */
  448.     return (xlgetprop(sym,prp));
  449. }
  450.  
  451. /* xputprop - set the value of a property */
  452. LVAL xputprop()
  453. {
  454.     LVAL sym,val,prp;
  455.  
  456.     /* get the symbol and property */
  457.     sym = xlgasymbol();
  458.     val = xlgetarg();
  459.     prp = xlgasymbol();
  460.     xllastarg();
  461.  
  462.     /* set the property value */
  463.     xlputprop(sym,val,prp);
  464.  
  465.     /* return the value */
  466.     return (val);
  467. }
  468.  
  469. /* xremprop - remove a property value from a property list */
  470. LVAL xremprop()
  471. {
  472.     LVAL sym,prp;
  473.  
  474.     /* get the symbol and property */
  475.     sym = xlgasymbol();
  476.     prp = xlgasymbol();
  477.     xllastarg();
  478.  
  479.     /* remove the property */
  480.     xlremprop(sym,prp);
  481.  
  482.     /* return nil */
  483.     return (NIL);
  484. }
  485.  
  486. /* xhash - compute the hash value of a string or symbol */
  487. LVAL xhash()
  488. {
  489.     unsigned char *str;
  490.     LVAL len,val;
  491.     int n;
  492.  
  493.     /* get the string and the table length */
  494.     val = xlgetarg();
  495.     len = xlgafixnum(); n = (int)getfixnum(len);
  496.     xllastarg();
  497.  
  498.     /* get the string */
  499.     if (symbolp(val))
  500.     str = getstring(getpname(val));
  501.     else if (stringp(val))
  502.     str = getstring(val);
  503.     else
  504.     xlbadtype(val);
  505.  
  506.     /* return the hash index */
  507.     return (cvfixnum((FIXTYPE)hash(str,n)));
  508. }
  509.  
  510. /* xaref - array reference function */
  511. LVAL xaref()
  512. {
  513.     LVAL array,index;
  514.     int i;
  515.  
  516.     /* get the array and the index */
  517.     array = xlgavector();
  518.     index = xlgafixnum(); i = (int)getfixnum(index);
  519.     xllastarg();
  520.  
  521.     /* range check the index */
  522.     if (i < 0 || i >= getsize(array))
  523.     xlerror("array index out of bounds",index);
  524.  
  525.     /* return the array element */
  526.     return (getelement(array,i));
  527. }
  528.  
  529. /* xmkarray - make a new array */
  530. LVAL xmkarray()
  531. {
  532.     LVAL size;
  533.     int n;
  534.  
  535.     /* get the size of the array */
  536.     size = xlgafixnum() ; n = (int)getfixnum(size);
  537.     xllastarg();
  538.  
  539.     /* create the array */
  540.     return (newvector(n));
  541. }
  542.  
  543. /* xvector - make a vector */
  544. LVAL xvector()
  545. {
  546.     LVAL val;
  547.     int i;
  548.  
  549.     /* make the vector */
  550.     val = newvector(xlargc);
  551.  
  552.     /* store each argument */
  553.     for (i = 0; moreargs(); ++i)
  554.     setelement(val,i,nextarg());
  555.     xllastarg();
  556.  
  557.     /* return the vector */
  558.     return (val);
  559. }
  560.  
  561. /* xerror - special form 'error' */
  562. LVAL xerror()
  563. {
  564.     LVAL emsg,arg;
  565.  
  566.     /* get the error message and the argument */
  567.     emsg = xlgastring();
  568.     arg = (moreargs() ? xlgetarg() : s_unbound);
  569.     xllastarg();
  570.  
  571.     /* signal the error */
  572.     xlerror(getstring(emsg),arg);
  573.     return(NIL);  /* to keep compilers happy - L. Tierney */
  574. }
  575.  
  576. /* xcerror - special form 'cerror' */
  577. LVAL xcerror()
  578. {
  579.     LVAL cmsg,emsg,arg;
  580.  
  581.     /* get the correction message, the error message, and the argument */
  582.     cmsg = xlgastring();
  583.     emsg = xlgastring();
  584.     arg = (moreargs() ? xlgetarg() : s_unbound);
  585.     xllastarg();
  586.  
  587.     /* signal the error */
  588.     xlcerror(getstring(cmsg),getstring(emsg),arg);
  589.  
  590.     /* return nil */
  591.     return (NIL);
  592. }
  593.  
  594. /* xbreak - special form 'break' */
  595. LVAL xbreak()
  596. {
  597.     LVAL emsg,arg;
  598.  
  599.     /* get the error message */
  600.     emsg = (moreargs() ? xlgastring() : NIL);
  601.     arg = (moreargs() ? xlgetarg() : s_unbound);
  602.     xllastarg();
  603.  
  604.     /* enter the break loop */
  605.     xlbreak((emsg ? getstring(emsg) : (unsigned char *)"**BREAK**"),arg);
  606.  
  607.     /* return nil */
  608.     return (NIL);
  609. }
  610.  
  611. /* xcleanup - special form 'clean-up' */
  612. LVAL xcleanup()
  613. {
  614.     xllastarg();
  615.     xlcleanup();
  616.     return(NIL);  /* to keep compilers happy - L. Tierney */
  617. }
  618.  
  619. /* xtoplevel - special form 'top-level' */
  620. LVAL xtoplevel()
  621. {
  622.     xllastarg();
  623.     xltoplevel();
  624.     return(NIL);  /* to keep compilers happy - L. Tierney */
  625. }
  626.  
  627. /* xcontinue - special form 'continue' */
  628. LVAL xcontinue()
  629. {
  630.     xllastarg();
  631.     xlcontinue();
  632.     return(NIL);  /* to keep compilers happy - L. Tierney */
  633. }
  634.  
  635. /* xevalhook - eval hook function */
  636. LVAL xevalhook()
  637. {
  638.     LVAL expr,newehook,newahook,newenv,oldenv,oldfenv,olddenv,val;
  639.  
  640.     /* protect some pointers */
  641.     xlstkcheck(3);
  642.     xlsave(oldenv);
  643.     xlsave(oldfenv);
  644.     xlsave(newenv);
  645.  
  646.     /* get the expression, the new hook functions and the environment */
  647.     expr = xlgetarg();
  648.     newehook = xlgetarg();
  649.     newahook = xlgetarg();
  650.     newenv = (moreargs() ? xlgalist() : NIL);
  651.     xllastarg();
  652.  
  653.     /* bind *evalhook* and *applyhook* to the hook functions */
  654.     olddenv = xldenv;
  655.     xldbind(s_evalhook,newehook);
  656.     xldbind(s_applyhook,newahook);
  657.  
  658.     /* establish the environment for the hook function */
  659.     if (newenv) {
  660.     oldenv = xlenv;
  661.     oldfenv = xlfenv;
  662.     xlenv = car(newenv);
  663.     xlfenv = cdr(newenv);
  664.     }
  665.  
  666.     /* evaluate the expression (bypassing *evalhook*) */
  667.     val = xlxeval(expr);
  668.  
  669.     /* restore the old environment */
  670.     xlunbind(olddenv);
  671.     if (newenv) {
  672.     xlenv = oldenv;
  673.     xlfenv = oldfenv;
  674.     }
  675.  
  676.     /* restore the stack */
  677.     xlpopn(3);
  678.  
  679.     /* return the result */
  680.     return (val);
  681. }
  682.